#! /usr/bin/env escript
% vim: filetype=erlang

%% Copyright (c) 2008, Paul Mineiro.
%% 
%% All rights reserved.
%% 
%% Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
%% 
%%     * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
%%     * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
%%     * Neither the name of Paul Mineiro nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
%% 
%% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
%% "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
%% LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
%% A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
%% CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
%% EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
%% PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
%% PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
%% LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
%% NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
%% SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-mode (compile).

%
% This is a large escript, but I wanted all the code in one place.
%

%-=====================================================================-
%-                       Form Analysis Functions                       -
%-                                                                     -
%- These take forms, as returned by compile:file/2, and                -
%- extract information from them.                                      -
%- Currently this is just inferred registered process names.           -
%-=====================================================================-

%% looks like fun_clauses are the same as clauses (?)
find_registered_fun_clauses (Clauses, Registered) ->
  find_registered_clauses (Clauses, Registered).

%% looks like icr_clauses are the same as clauses (?)
find_registered_icr_clauses (Clauses, Registered) ->
  find_registered_clauses (Clauses, Registered).

find_registered_inits (Inits, Registered) ->
  lists:foldl (fun ({ record_field, _, _, E }, R) ->
                 find_registered_expr (E, R);
                   (_, R) ->
                 R
               end,
               Registered,
               Inits).

find_registered_upds (Upds, Registered) ->
  lists:foldl (fun ({ record_field, _, _, E }, R) ->
                 find_registered_expr (E, R);
                   (_, R) ->
                 R
               end,
               Registered,
               Upds).

% hmmm ... pretty sure patterns are not supposed to have side-effects ...
find_registered_pattern (_, Registered) -> 
  Registered.

find_registered_pattern_group (_, Registered) -> 
  Registered.

find_registered_quals (Qs, Registered) ->
  lists:foldl (fun ({ generate, _, P, E }, R) ->
                 find_registered_expr (E,
                   find_registered_pattern (P, R));
                   ({ b_generate, _, P, E }, R) ->
                 find_registered_expr (E,
                   find_registered_pattern (P, R));
                   (E, R) ->
                 find_registered_expr (E, R)
               end,
               Registered,
               Qs).

find_registered_expr ({ atom, _, _ }, Registered) ->
  Registered;
find_registered_expr ({ var, _, _ }, Registered) ->
  Registered;
find_registered_expr ({ nil, _ }, Registered) ->
  Registered;
find_registered_expr ({ string, _, _ }, Registered) ->
  Registered;
find_registered_expr ({ integer, _, _ }, Registered) ->
  Registered;
find_registered_expr ({ char, _, _ }, Registered) ->
  Registered;
find_registered_expr ({ float, _, _ }, Registered) ->
  Registered;
find_registered_expr ({ cons, _, H, T }, Registered) ->
  find_registered_expr (T, find_registered_expr (H, Registered));
find_registered_expr ({ lc, _, E, Qs }, Registered) ->
  find_registered_quals (Qs, find_registered_expr (E, Registered));
find_registered_expr ({ bc, _, E, Qs }, Registered) ->
  find_registered_quals (Qs, find_registered_expr (E, Registered));

%% Ok, here's some meat:
%% the "supervisor child spec" rule
%% { _, start, [ { local, xxx }, ... ] } -> xxx being registered
%% { _, start_link, [ { local, xxx }, ... ] } -> xxx being registered
%%
find_registered_expr ({ tuple, _,
                        Exprs=[ _,
                          { atom, _, Func },
                          { cons, 
                            _, 
                            { tuple, _, [ { atom, _, local }, 
                                          { atom, _, Name } ] },
                            _ } ] },
                      Registered) when (Func =:= start) or
                                       (Func =:= start_link) ->
  find_registered_exprs (Exprs, [ Name | Registered ]);

find_registered_expr ({ tuple, _, Exprs }, Registered) ->
  find_registered_exprs (Exprs, Registered);
find_registered_expr ({ record_index, _, _, E }, Registered) ->
  find_registered_expr (E, Registered);
find_registered_expr ({ record, _, _, Inits }, Registered) ->
  find_registered_inits (Inits, Registered);
find_registered_expr ({ record_field, _, E0, _, E1 }, Registered) ->
  find_registered_expr (E1, find_registered_expr (E0, Registered));
find_registered_expr ({ record, _, E, _, Upds }, Registered) ->
  find_registered_upds (Upds, find_registered_expr (E, Registered));
find_registered_expr ({ record_field, _, E0, E1 }, Registered) ->
  find_registered_expr (E1, find_registered_expr (E0, Registered));
find_registered_expr ({ block, _, Exprs }, Registered) ->
  find_registered_exprs (Exprs, Registered);
find_registered_expr ({ 'if', _, IcrClauses }, Registered) ->
  find_registered_icr_clauses (IcrClauses, Registered);
find_registered_expr ({ 'case', _, E, IcrClauses }, Registered) ->
  find_registered_icr_clauses (IcrClauses,
                               find_registered_expr (E, Registered));
find_registered_expr ({ 'receive', _, IcrClauses }, Registered) ->
  find_registered_icr_clauses (IcrClauses, Registered);
find_registered_expr ({ 'receive', _, IcrClauses, E, Exprs }, Registered) ->
  find_registered_exprs 
    (Exprs,
     find_registered_expr (E, 
                           find_registered_icr_clauses (IcrClauses,
                                                        Registered)));
find_registered_expr ({ 'try', _, Exprs0, IcrClauses0, IcrClauses1, Exprs1 }, 
                      Registered) ->
  find_registered_exprs (Exprs1,
    find_registered_icr_clauses (IcrClauses1,
      find_registered_icr_clauses (IcrClauses0,
        find_registered_exprs (Exprs0, Registered))));
find_registered_expr ({ 'fun', _, Body }, Registered) ->
  case Body of
    { clauses, Cs } ->
      find_registered_fun_clauses (Cs, Registered);
    _ ->
      Registered
  end;
%% dunno what this is, assuming nothing registered in the Wtf section
find_registered_expr ({ 'fun', _, Body, _Wtf }, Registered) ->
  case Body of
    { clauses, Cs } ->
      find_registered_fun_clauses (Cs, Registered);
    _ ->
      Registered
  end;

%% Ok, here's some meat:
%% Module:start ({ local, xxx }, ...) -> xxx being registered
%% Module:start_link ({ local, xxx }, ...) -> xxx being registered
%%
find_registered_expr ({ call, 
                        _, 
                        E={ remote, _, _, { atom, _, Func } },
                        Exprs=[ { tuple, _, [ { atom, _, local },
                                              { atom, _, Name } ] } | _ ] },
                      Registered) 
                           when (Func =:= start) or
                                (Func =:= start_link) ->
  find_registered_exprs (Exprs,
                         find_registered_expr (E, [ Name | Registered ]));

%% Ok, here's some meat:
%% erlang:register (xxx, ...) -> xxx being registered
%%
find_registered_expr ({ call, 
                        _,
                        { remote, 
                          _, 
                          { atom, _, erlang }, 
                          { atom, _, register } },
                        Exprs=[ { atom, _, Name } | _ ] },
                      Registered) ->
  find_registered_exprs (Exprs, [ Name | Registered ]);
%% more meat: the same, auto-imported
find_registered_expr ({ call, 
                        _,
                        { atom, _, register },
                        Exprs = [ { atom, _, Name } | _ ] },
                      Registered) ->
  find_registered_exprs (Exprs, [ Name | Registered ]);

find_registered_expr ({ call, _, E, Exprs }, Registered) ->
  find_registered_exprs (Exprs, find_registered_expr (E, Registered));
find_registered_expr ({ 'catch', _, E }, Registered) ->
  find_registered_expr (E, Registered);
find_registered_expr ({ 'query', _, E }, Registered) ->
  find_registered_expr (E, Registered);
find_registered_expr ({ match, _, P, E }, Registered) ->
  find_registered_expr (E, find_registered_pattern (P, Registered));
find_registered_expr ({ bin, _, PatternGrp }, Registered) ->
  find_registered_pattern_group (PatternGrp, Registered);
find_registered_expr ({ op, _, _, E }, Registered) ->
  find_registered_expr (E, Registered);
find_registered_expr ({ op, _, _, E0, E1 }, Registered) ->
  find_registered_expr (E1, find_registered_expr (E0, Registered));
find_registered_expr ({ remote, _, E0, E1 }, Registered) ->
  find_registered_expr (E1, find_registered_expr (E0, Registered));
find_registered_expr (Form, Registered) ->
  port_command (get (stderr), 
                io_lib:format ("warning: unrecognized form: ~p~n", [ Form ])),
  Registered.

find_registered_exprs (Exprs, Registered) ->
  lists:foldl (fun find_registered_expr/2, Registered, Exprs).

find_registered_clauses (Clauses, Registered) ->
  lists:foldl (fun ({ clause, _, _, _, Exprs }, Acc) ->
                 find_registered_exprs (Exprs, Acc);
                   (_, Acc) ->
                 Acc
               end,
               Registered,
               Clauses).

find_registered (Forms) ->
  lists:foldl (fun ({ function, _, _, _, Clauses }, Registered) -> 
                 find_registered_clauses (Clauses, Registered);
                   (_, Registered) ->
                 Registered
               end,
               [],
               Forms).

is_skipped (Forms) -> 
  lists:any (fun ({ attribute, _, fwskip, _ }) -> true;
                 (_) -> false
             end,
             Forms).

is_application (Forms) ->
  lists:any (fun ({ attribute, _, behaviour, application }) -> true;
                 ({ attribute, _, behavior, application }) -> true;
                 (_) -> false
             end,
             Forms).

find_module (Forms) ->
  lists:foldl 
    (fun ({ attribute, _, module, Module }, Acc) when is_atom (Module) -> 
            [ Module | Acc ];
         ({ attribute, _, module, { Module, _ } }, Acc) when is_atom (Module) ->
            % parametrized module
            [ Module | Acc ];
         (_, Acc) -> Acc
            end,
     [],
     Forms).

analyze_file (F, Includes, Defines) ->
  case epp:parse_file (F, Includes, Defines) of
    { ok, Forms } ->
      case is_skipped (Forms) of
        true ->
          { [], [], [] };
        false ->
          [ Mod ] = find_module (Forms),
          { find_registered (Forms), 
            [ Mod ],
            case is_application (Forms) of true -> [ Mod ]; false -> [] end }
      end;
    X ->
      port_command (get (stderr),
                    io_lib:format 
                      ("error: epp:parse_file/3 for ~p returned ~p~n",
                       [ F,
                         X ])), 
      { [], [], [] }
  end.

usage () ->
  port_command (get (stderr), 
                "usage: fwte-makeappfile [args] filename [ filename ... ]\n"
                "\n"
                "  where args is one of:\n"
                "   -I directory\n"
                "     add include path, same as -I argument to erlc\n"
                "\n"
                "   -Dname\n"
                "     Defines a macro, same as -D argument to erlc.\n"
                "\n"
                "   -Dname=value\n"
                "     Defines a macro, same as -D argument to erlc.\n"
                "\n"
                "   --application Application\n"
                "     specify application name (required)\n"
                "\n"
                "   --description Description\n"
                "     specify application description (required)\n"
                "\n"
                "   --env Environment\n"
                "     specify application environment\n"
                "\n"
                "   --extra Extra\n"
                "     specify extra key-value pairs for application\n"
                "\n"
                "   --modules Modules\n"
                "     manually specify list of modules\n"
                "\n"
                "   --mod Mod\n"
                "     manually specify start module and arguments\n"
                "\n"
                "   --prereqs Prereqs\n"
                "     specify list of prerequisite applications\n"
                "\n"
                "   --registered Registered\n"
                "     manually specify list of registered processes\n"
                "\n"
                "   --version Version\n"
                "     specify application version (required)\n"
                "\n"),
  timer:sleep (100),
  halt (1).

eval (S) ->
  try
    { ok, Scanned, _ } = erl_scan:string (S ++ "."),
    { ok, Parsed } = erl_parse:parse_exprs (Scanned),
    { value, Value, _ } = erl_eval:exprs (Parsed, erl_eval:new_bindings ()),
    Value
  catch
    _ : _ -> 
      port_command 
        (get (stderr), 
         io_lib:format ("error: attempted to eval nonsense string: ~p~n",
                        [ S ])),
      usage ()
  end.

parse_args ([ "-I", Include | Rest ], Proplist) ->
  parse_args (Rest, [ { include, Include } | Proplist ]);
parse_args ([ "-D" ++ Macro | Rest ], Proplist) ->
  case string:tokens (Macro, "=") of
    [ Name ] -> 
      parse_args (Rest, 
                  [ { define, list_to_atom (Name), true } | Proplist ]);
    [ Name, Value ] ->
      parse_args (Rest,
                  [ { define, list_to_atom (Name), eval (Value) } | Proplist ]);
    _ ->
      port_command (get (stderr), 
                    io_lib:format ("error: bad argument -D~p~n", [ Macro ])),
      usage ()
  end;
parse_args ([ "--application", Application | Rest ], Proplist) ->
  parse_args (Rest, [ { application, eval (Application) } | Proplist ]);
parse_args ([ "--description", Description | Rest ], Proplist) ->
  parse_args (Rest, [ { description, Description } | Proplist ]);
parse_args ([ "--env", Environment | Rest ], Proplist) ->
  parse_args (Rest, [ { env, eval (Environment) } | Proplist ]);
parse_args ([ "--extra", Extra | Rest ], Proplist) ->
  parse_args (Rest, [ { extra, eval (Extra) } | Proplist ]);
parse_args ([ "--modules", Modules | Rest ], Proplist) ->
  parse_args (Rest, [ { modules, eval (Modules) } | Proplist ]);
parse_args ([ "--mod", Mod | Rest ], Proplist) ->
  parse_args (Rest, [ { mod, eval (Mod) } | Proplist ]);
parse_args ([ "--prereqs", Prereqs | Rest ], Proplist) ->
  parse_args (Rest, [ { prereqs, eval (Prereqs) } | Proplist ]);
parse_args ([ "--registered", Registered | Rest ], Proplist) ->
  parse_args (Rest, [ { registered, eval (Registered) } | Proplist ]);
parse_args ([ "--version", Version | Rest ], Proplist) ->
  parse_args (Rest, [ { version, Version } | Proplist ]);
parse_args (Files, Proplist) ->
  [ { files, Files } | Proplist ].

parse_args (Args) ->
  parse_args (Args, []).

application (Config) ->
  case proplists:get_value (application, Config) of
    undefined ->
      port_command (get (stderr), "error: application not specified\n"),
      usage ();
    X ->
      X
  end.

defines (Config) ->
  [ { X, Y } || { define, X, Y } <- proplists:get_all_values (define, Config) ].

description (Config) ->
  case proplists:get_value (description, Config) of
    undefined ->
      port_command (get (stderr), "error: description not specified\n"),
      usage ();
    X ->
      X
  end.

env (Config) ->
  case proplists:get_value (env, Config) of
    undefined -> [];
    X -> X
  end.

extra (Config) ->
  case proplists:get_value (extra, Config) of
    undefined -> [];
    X -> X
  end.

files (Config) ->
  case proplists:get_value (files, Config) of
    undefined -> [];
    X -> X
  end.

includes (Config) ->
  proplists:get_all_values (include, Config).

mod (Config, Mod) ->
  case case proplists:get_value (mod, Config) of
         undefined -> Mod;
         X -> X
       end of
    [] -> [];
    [ Y ] -> [ { mod, { Y, [] } } ];
    Z -> 
      port_command (get (stderr), 
                    io_lib:format ("error: multiple start modules detected: "
                                   "~p~n", [ Z ])),
      timer:sleep (100),
      halt (1)
  end.

modules (Config, Modules) ->
  case proplists:get_value (modules, Config) of
    undefined -> lists:usort (Modules);
    X -> lists:usort (X)
  end.

prereqs (Config) ->
  case proplists:get_value (prereqs, Config) of
    undefined -> [];
    X -> X
  end.

registered (Config, Registered) ->
  case proplists:get_value (registered, Config) of
    undefined -> lists:usort (Registered);
    X -> lists:usort (X)
  end.

version (Config) ->
  case proplists:get_value (version, Config) of
    undefined ->
      port_command (get (stderr), "error: version not specified\n"),
      usage ();
    X ->
      X
  end.

main (Args) ->
  put (stderr, open_port ({ fd, 0, 2 }, [ out ])),
  Config = parse_args (Args),
  { Registered, Modules, Start } = 
    lists:foldl (fun (F, { R, M, S }) -> 
                  { NewR, NewM, NewS } = analyze_file (F, 
                                                       includes (Config),
                                                       defines (Config)),
                  { NewR ++ R, NewM ++ M, NewS ++ S }
                 end,
                 { [], [], [] },
                 files (Config)),

  App = { application,
          application (Config),
          [ { description, description (Config) },
            { vsn, version (Config) },
            { modules, modules (Config, Modules) },
            { registered, registered (Config, Registered) },
            { applications, [ kernel, stdlib | prereqs (Config) ] },
            { env, env (Config) } ] ++
            mod (Config, Start) ++
            extra (Config) },

  io:format ("~p~n.", [ App ]),
  timer:sleep (1000).
